# $Id: stdlib.tcl 7557b5d4d82b 2012/12/02 09:07:16 pgurumur $
# Copyright (c) 2009 Prabhu Gurumurthy  <pgurumur@gmail.com>
# 
# Permission to use, copy, modify, and distribute this software for any
# purpose with or without fee is hereby granted, provided that the above
# copyright notice and this permission notice appear in all copies.
#
# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
#

# version "$Revision: 7557b5d4d82b $"
# author "$Author: pgurumur $"

namespace eval stdlib {
   namespace export randstring
   namespace export randint
   namespace export pack2ip
   namespace export ip2pack
   namespace export netmask
   namespace export netaddr
   namespace export basename
   namespace export lsrev
   namespace export getprime
   namespace export range
   namespace export isprime
   namespace export ipv6pack
   namespace export sleep
   set version 1.0
   set progname ""
}

proc stdlib::basename { program } {
   global progname
   if {[string length $program] > 0 } {
      set progname $program
   }
}

proc stdlib::setrandom {} {
   global tcl_platform
   set uname $tcl_platform(os)
   set randfile ""

   if {$uname == "OpenBSD"} {
      set randfile /dev/arandom
   } elseif {$uname == "Linux"} {
      set randfile /dev/urandom
   } elseif {$uname == "Darwin"} {
      set randfile /dev/random
   } elseif {$uname == "NetBSD"} {
      set randfile /dev/urandom
   }

   return $randfile
}

proc stdlib::_error mesg {
   global progname
   if {[string length $mesg] > 0} {
      if {[string length $progname] > 0 } {
         puts "$progname: $mesg"
      } else {
         puts $mesg
      }
   }

   exit 1
}

proc stdlib::_readrandom length {
   set randfile [stdlib::setrandom]
   set retval ""
   set rand [open $randfile]
   set retval [read $rand $length]
   close $rand
   return $retval
}

proc stdlib::_randdata retarray {
   upvar $retarray retval
   array set retval {}
   set data [stdlib::_readrandom 100]
   for {set ix 0} {$ix < [string length $data]} {incr ix} {
      set char [string index $data $ix]
      scan $char %c ascii
      set retval($ascii) $char
   }

   array get retval
}

proc stdlib::_checkip addr {
   set count 0
   foreach octet [split $addr "."] {
      incr count
   }

   if {$count < 4 || $count > 4} {
      stdlib::_error "invalid ip address $addr"
   }
}

proc stdlib::_ip addr {
   set retval ""
   set temp [list]
   set count 0
   foreach octet [split $addr "."] {
      incr count
      if {$count <= 4 && $count > 0} {
         if {$octet < 0 || $octet > 255} {
            stdlib::_error "invalid $count octet: $octet"
         } else {
            lappend temp $octet
         }
      } else {
         stdlib::_error "invalid ip address $addr"
      }
   }

   if {$count < 4} {
      set maxval 4
      for {set ix [llength $temp]} {$ix < $maxval} {incr ix} {
         lappend temp 0
      }

      set retval [join $temp "."]
   } elseif {$count == 4} {
      set retval $addr
   }

   return $retval
}

proc stdlib::_genrandom {} {
   set retval ""
   array set data [ stdlib::_randdata data ]

   foreach element [array names data] {
      set ascii $element
      set char $data($element)
      if {$ascii >= 48 && $ascii <= 57} {
         if {$ascii == 48} {
            if {[string length $retval] >= 1} {
               append retval $char
            }
         } else {
            append retval $char
         }
      }
   }

   return $retval
}

proc stdlib::range args {
   foreach {start stop step} [switch -exact -- [llength $args] {
      1 {concat 0 $args 1}
      2 {concat   $args 1}
      3 {concat   $args  }
      default {
         stdlib::_error "wrong # f args: should be range start stop {step}"
      }
   }] break

   if {$step == 0} {
      stdlib::_error "cannot create range when step is zero"
   }

   set range [list]
   while {$step > 0 ? $start < $stop : $stop < $start} {
      lappend range $start
      incr start $step
   }

   return $range
}

proc stdlib::randstring length {
   set flag 1
   set retval ""

   while {$flag == 1} {
      array set data [stdlib::_randdata data]
      foreach element [array names data] {
         set ascii $element
         set char $data($element)
         if {[string length $retval] < $length} {
            if {$ascii >= 97 && $ascii <= 122} {
               append retval $char
            } elseif {$ascii >= 65 && $ascii <= 90} {
               append retval $char
            }
         } else {
            set flag 0
         }
      }
   }
   
   return $retval
}

proc stdlib::randint { min max } {
   set flag 1
   set retval 0
   set minval 0
   set maxval 0

   if {$min == $max} {
      set retval $max
   } elseif {$min > $max} {
      set minval $max
      set maxval $min
   } else {
      set minval $min
      set maxval $max
   }

   if {$minval && $maxval} {
      while {$flag == 1} {
         set rand [stdlib::_genrandom]
         if {$rand <= $maxval && $rand >= $minval} {
            set retval $rand
            set flag 0
         }
      }

      puts $retval
   }

   return $retval
}

proc stdlib::lsrev value {
   set retval [list]
   set listlen [llength $value]
   if {$listlen > 1} {
      for {set ix $listlen} {$ix >= 0} {incr ix -1} {
         set temp [lindex $value $ix]
         if {[string length $temp] > 0} {
            lappend retval $temp
         }
      }
   }

   return $retval
}

proc stdlib::pack2ip value {
   set range [stdlib::range 0 4]
   set retval ""
   set var [list]
   set maxval [expr 2 << 31]
   if {$maxval <= 0} {
      set maxval [expr round(pow(2, 32))]
   }

   if {$value > $maxval} {
      stdlib::_error "Invalid integer value '$value' to unpack"
   }

   foreach ix $range {
      lappend var [expr $value & 0xff]
      set value [expr $value >> 8]
   }

   if {[catch {set retval [join [lreverse $var] "."]} err]} {
      set retval [join [stdlib::lsrev $var] "."]
   }
   return $retval
}

proc stdlib::ip2pack value {
   set retval 0
   set count 0
   set var [split $value '/']
   set value [lindex $var 0]

   stdlib::_checkip $value
   foreach octet [split $value "."] {
      if {$count == 0} {
         set retval [expr $retval | [expr $octet << 24]]
      } elseif {$count == 1} {
         set retval [expr $retval | [expr $octet << 16]]
      } elseif {$count == 2} {
         set retval [expr $retval | [expr $octet << 8]]
      } elseif {$count == 3} {
         set retval [expr $retval | $octet]
      }

      incr count
   }

   return $retval
}

proc stdlib::netmask { number wildcard } {
   set retval ""
   set bits 0
   set ipvalmax 32

   if {$number > $ipvalmax} {
      stdlib::_error "Netmask cannot be greater than 32"
   } elseif {$number <= 0 } {
      stdlib::_error "Netmask cannot be less than or equal to zero"
   } else {
      set operator [expr $ipvalmax - $number]
      set maskval [expr 1 << $operator]
      set maxval [expr [expr 2 << 31] - 1]
      if {$maxval <= 0} {
         set maxval [expr [expr round(pow(2, 32))] - 1]
      }

      if {$wildcard == 1} {
         set bits [expr [expr 0 ^ $maskval] - 1]
      } else {
         set bits [expr [expr $maxval ^ $maskval] + 1]
      }

      set retval [stdlib::pack2ip $bits]
   }

   return $retval
}

proc stdlib::netaddr { subnet } {
   set var [split $subnet '/']
   set ip [lindex $var 0]
   set netlen [lindex $var 1]
   if {[string length $netlen] <= 0 } {
      set netlen 32
   }

   set ip [stdlib::_ip $ip]

   set mask [stdlib::netmask $netlen 0]
   set left [expr 32 - $netlen]
   set wildcard [stdlib::netmask $netlen 1]
   set temp [expr [stdlib::ip2pack $mask] & [stdlib::ip2pack $ip]]
   set network [stdlib::pack2ip $temp]
   set broadcast [stdlib::pack2ip [expr $temp + [expr [expr 1 << $left] - 1]]]

   set maxip [expr 1 << $left]
   set usableip 0
   if {$maxip <= 2} {
      set usableip $maxip
   } else {
      set usableip [expr $maxip - 2]
   }

   if {$netlen < 32} {
      if {$netlen == 31} {
         set lastip $broadcast
         set firstip $network
      } else {
         set lastip [stdlib::pack2ip [
            expr $temp + [expr [expr 1 << $left] - 2]]]
         set firstip [stdlib::pack2ip [expr $temp + 1]]
      }
   } elseif {$netlen == 32} {
      set firstip $network
      set lastip $network
   }

   set address(ip) $ip
   set address(mask) $netlen
   set address(netmask) $mask
   set address(wildcard) $wildcard
   set address(network) $network
   set address(broadcast) $broadcast
   set address(firstip) $firstip
   set address(lastip) $lastip
   set address(maxip) $maxip
   set address(usableip) $usableip

   array get address
}

proc stdlib::getprime { number { start 2 } } {
   set retval ""
   if {$number < 0} {
      stdlib::_error "Invalid number"
   } elseif {$number == 1} {
      set retval number
   } elseif {$number == 2} {
      set retval number
   } else {
      set retval [list]
      set nums [stdlib::range 3 [expr $number + 1] 2]
      set nlen [expr [expr {$number / 2} - 1] + [expr {$number % 2}]]
      set idx 0
      set idxsqrt [expr {[expr [expr int(pow($number, 0.5))] - 3] / 2}]
      lappend retval 2

      while {$idx <= $idxsqrt} {
         set nidx [expr [expr $idx << 1] + 3]
         set range [stdlib::range [expr $idx * ($nidx + 3) + 3] $nlen $nidx]
         foreach value $range {
            set nums [lreplace $nums $value $value 0]
         }

         incr idx 1
         while {$idx <= $idxsqrt} {
            set value [lindex $nums $idx]
            if {$value != 0} {
               break
            }

            incr idx 1
         }
      }

      foreach ix $nums {
         if {$ix != 0} {
            lappend retval $ix
         }
      }
   }

   set temp [list]
   if {$start} {
      foreach value $retval {
         if {$value >= $start} {
            lappend temp $value
         }
      }

      set retval $temp
   }

   return $retval
}

proc stdlib::isprime { number } {
   set retval ""
   set temp [expr $number & 1]
   if {$number < 2} {
      set retval 0
   } elseif {$number == 2} {
      set retval 1
   } elseif {!$temp} {
      set retval 0
   } else {
      set value [stdlib::range 3 [expr [expr int(pow($number, 0.5))] + 1] 2]
      foreach ix $value {
         if {[expr $number % $ix] == 0} {
            set retval 0
            break
         }
      }

      if {[string length $retval] == 0} {
         set retval 1
      }
   }

   return $retval
}

proc stdlib::_hex2int { number } {
   set retval 0
   scan $number %x retval
   return $retval
}

proc stdlib::ipv6pack { v6string } {
   set ipint 0
   set records [ split $v6string ":" ]
   foreach rec $records {
      puts [stdlib::_hexint $rec]
      set ipint [expr [ expr $ipint << 16 ] + [ stdlib::_hexint $rec ]]
   }

   return $ipint
}

proc stdlib::sleep seconds {
   if {$seconds} {
      set secs [expr 1000 * $seconds]
      time {after $secs}
   }
}

proc stdlib::? {} { lsort [info procs ::stdlib::*] }
package provide stdlib $stdlib::version
